home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DOS.SWG / 0002_Assign New Environment.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  4KB  |  127 lines
  1. {
  2.  The following TP code assigns a new Environment to the COMMand.COM
  3.  which is invoked by TP's EXEC Function.  In this Case, it is used
  4.  to produce a Dos PROMPT which is different from the one in the Master
  5.  Environment.  Control is returned when the user Types Exit ...
  6. }
  7.  
  8. { Reduce Retained Memory }
  9.  
  10. {$M 2048,0,0}
  11.  
  12. Program NewEnv;
  13. Uses
  14.   Dos;
  15. Type
  16.   String128   = String[128];
  17. Const
  18.   NewPrompt   =
  19.     'PROMPT=$e[32mType Exit to Return to The Fitness Profiler$e[0m$_$_$p$g' + #0;
  20. Var
  21.   EnvironNew,
  22.   EnvironOld,
  23.   offsetN,
  24.   offsetO,
  25.   SegBytes    : Word;
  26.   TextBuff    : String128;
  27.   Found,
  28.   Okay        : Boolean;
  29.   Reg         : Registers;
  30.  
  31. Function AllocateSeg( BytesNeeded : Word ) : Word;
  32. begin
  33.   Reg.AH := $48;
  34.   Reg.BX := BytesNeeded div 16;
  35.   MsDos( Reg );
  36.   if Reg.Flags and FCarry <> 0 then
  37.     AllocateSeg := 0
  38.   else
  39.     AllocateSeg := Reg.AX;
  40. end {AllocateSeg};
  41.  
  42. Procedure DeAllocateSeg( AllocSeg : Word; Var okay : Boolean );
  43. begin
  44.   Reg.ES := AllocSeg;
  45.   Reg.AH := $49;
  46.   MsDos( Reg );
  47.   if Reg.Flags and FCarry <> 0 then
  48.     okay := False
  49.   else
  50.     okay := True;
  51. end {DeAllocateSeg};
  52.  
  53. Function EnvReadLn( EnvSeg : Word; Var Envoffset : Word ) : String128;
  54. Var
  55.   tempstr : String128;
  56.   loopc   : Byte;
  57. begin
  58.   loopc := 0;
  59.   Repeat
  60.     inC( loopc );
  61.     tempstr[loopc] := CHR(Mem[EnvSeg:Envoffset]);
  62.     inC( Envoffset );
  63.   Until tempstr[loopc] = #0;
  64.   tempstr[0] := CHR(loopc);       {set str length}
  65.   EnvReadLn := tempstr
  66. end {ReadEnvLn};
  67.  
  68. Procedure EnvWriteLn( EnvSeg : Word; Var Envoffset : Word;
  69.                       AsciizStr : String );
  70. Var
  71.   loopc   : Byte;
  72. begin
  73.   For loopc := 1 to Length( AsciizStr ) do
  74.   begin
  75.     Mem[EnvSeg:Envoffset] := orD(AsciizStr[loopc]);
  76.     inC( Envoffset )
  77.   end
  78. end {EnvWriteLn};
  79.  
  80. begin   {main}
  81.   WriteLn(#10,'NewEnv v0.0 Dec.25.91 Greg Vigneault');
  82.   SegBytes := 1024;    { size of new environment (up to 32k)}
  83.   EnvironNew := AllocateSeg( SegBytes );
  84.   if EnvironNew = 0 then
  85.   begin    { asked For too much memory? }
  86.     WriteLn('Can''t allocate memory segment Bytes.',#7);
  87.     Halt(1)
  88.   end;
  89.   EnvironOld := MemW[ PrefixSeg:$002c ];   { current environ }
  90.   { copy orig env, but change the PROMPT command }
  91.   Found := False;
  92.   offsetO := 0;
  93.   offsetN := 0;
  94.   Repeat  { copy one env Var at a time, old env to new env}
  95.     TextBuff := EnvReadLn( EnvironOld, offsetO );
  96.     if offsetO >= SegBytes then
  97.     begin { not enough space? }
  98.       WriteLn('not enough new Environment space',#7);
  99.       DeAllocateSeg( EnvironNew, okay );
  100.       Halt(2)     { abort to Dos }
  101.     end;
  102.     { check For the PROMPT command String }
  103.     if Pos('PROMPT=',TextBuff) = 1 then
  104.     begin { prompt command? }
  105.       TextBuff := NewPrompt;          { set new prompt }
  106.       Found := True;
  107.     end;
  108.     { now Write the Variable to new environ }
  109.     EnvWriteLn( EnvironNew, offsetN, TextBuff );
  110.     { loop Until all Variables checked/copied }
  111.   Until Mem[EnvironOld:offsetO] = 0;
  112.   { if no prompt command found, create one }
  113.   if not Found then
  114.     EnvWriteLn( EnvironNew, offsetN, NewPrompt );
  115.   Mem[EnvironNew:offsetN] := 0;           { delimit new environ}
  116.   MemW[ PrefixSeg:$2c ] := EnvironNew;    { activate new env }
  117.   WriteLn( #10, '....Type Exit to return to normal prompt...' );
  118.   SwapVectors;
  119.   Exec( GetEnv('COMSPEC'),'/S');  {shell to Dos w/ new prompt}
  120.   SwapVectors;
  121.   MemW[ PrefixSeg:$2c ] := EnvironOld;   { restore original env}
  122.   DeAllocateSeg( EnvironNew, okay );
  123.   if not okay then
  124.     WriteLn( 'Could not release memory!',#7 );
  125. end {NewEnv}.
  126. (*******************************************************************)
  127.